home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FPCDOCS.LZH / KERNEL1.SEQ < prev    next >
Text File  |  1988-09-29  |  31KB  |  974 lines
  1. \ KERNEL1.SEQ  Source code for KERNEL1.COM,   modified by Tom Zimmer
  2.  
  3. ONLY FORTH   META ALSO FORTH
  4.  
  5. TRUE    CONSTANT INLINE_NEXT    \ Enable Inline NEXT
  6.  
  7. DECIMAL
  8.  
  9. : ?.INLINE      ( --- )         \ Print state of INLINE_NEXT
  10.                 CR ." NEXT is currently " INLINE_NEXT >REV
  11.                 IF      [ASSEMBLER] INLINEON  [FORTH]
  12.                         ."  INLINE. "
  13.                 ELSE    [ASSEMBLER] INLINEOFF [FORTH]
  14.                         ."  NOT " >NORM ."  INLINE. "
  15.                 THEN    >NORM CR ;
  16. ?.INLINE
  17.  
  18.    256 DP-T !           \ Set Dictionary pointer
  19.      0 DP-X !           \ Set LIST DP
  20.  
  21. HERE   9000 + ' TARGET-ORIGIN >BODY !
  22.  
  23. IN-META
  24.  
  25. : ]]   ]   ;
  26. : [[   [COMPILE] [   ; FORTH IMMEDIATE META
  27.  
  28. FORWARD: DEFINITIONS
  29. FORWARD: [
  30.  
  31. LABEL ORIGIN    JMP HERE 8000 + \ jump to cold start: will be patched
  32.                 JMP HERE 8000 + \ jump to warm start: will be patched
  33.                 END-CODE
  34.  
  35. LABEL DPUSH     PUSH DX         END-CODE
  36. LABEL APUSH     PUSH AX         END-CODE
  37. LABEL >NEXT     LODSW ES:
  38.                 JMP AX          END-CODE
  39.  
  40. \ Create the FORTH vocabulary as the first definition in dictionary.
  41.  
  42. HERE-T ,-Y                      \ valid "previous" CFA for "CREATE
  43.  
  44. HERE-Y HERE-T CNHASH !-Y        \ first entry in >NAME hash table
  45.  
  46. HERE-T DUP 100 + CURRENT-T !    \ harmless
  47.  
  48. HERE-Y VOCABULARY FORTH   FORTH DEFINITIONS
  49.  
  50. 0 OVER 2+ !-Y ( link )
  51.  
  52. 2+ SWAP  >BODY-T
  53. ASCII F 2*                      \ Hash in First char shifted left one
  54. ASCII O + 2*                    \ Plus second char, sum shifted left one
  55. 5 +                             \ Plus length byte
  56. #TTHREADS 1- AND 2*             \ Determine which thread FORTH goes in.
  57. + !-T                           \ store it in the proper thread.
  58.  
  59. IN-META
  60.  
  61. VOCABULARY FILES
  62.  
  63. FILES DEFINITIONS
  64.  
  65. \ Create the linked list of files that have been loaded.
  66.  
  67. VARIABLE KERNEL1.SEQ
  68.  
  69. FORTH DEFINITIONS
  70.  
  71. VARIABLE XSEG
  72. VARIABLE YSEG
  73.  
  74. LABEL ABNORM    MOV AX, # $AD26          \ Value to restore in >NEXT
  75.                 MOV >NEXT AX            \ Restore it
  76.                 MOV AX, # $E0FF          \ Value to restore in >NEXT + 2
  77.                 MOV >NEXT 2+ AX         \ Restore it
  78.                 XOR AX, AX
  79.                 MOV DS, AX
  80.                 MOV BX, # $471
  81.                 MOV 0 [BX], AL
  82.                 MOV AX, CS
  83.                 MOV DS, AX
  84.                 JMP ORIGIN 3 +  END-CODE
  85.  
  86. LABEL BIOSBK    PUSH AX
  87.                 MOV AL, # $E9
  88.                 MOV CS: >NEXT AL
  89.                 MOV AX, # ABNORM >NEXT - 3 -
  90.                 MOV CS: >NEXT 1+ AX
  91.                 POP AX
  92.                 IRET            END-CODE
  93.  
  94. LABEL DOSBK     PUSH AX
  95.                 MOV AH, # 0             \ throw away BREAK KEY
  96.                 INT $16
  97.                 POP AX
  98.                 CLC
  99.                 RETF            END-CODE
  100.  
  101. LABEL NEST              \ JMP = 15 cycles
  102.         XCHG RP, SP     \  4 cycles
  103.         PUSH ES         \ 10 sysles
  104.         PUSH IP         \ 11 cycles
  105.         XCHG RP, SP     \  4 cycles
  106.         MOV DI, AX      \  2 cycles
  107.         MOV AX, 3 [DI]  \ 18 cycles     \ get relative segment
  108.         ADD AX, XSEG    \ 15 cycles     \ adjust by base of list space
  109.         MOV ES, AX      \  2 cycles     \ move into ES
  110.         SUB IP, IP      \  3 cycles     \ clear IP
  111.         NEXT
  112.         END-CODE
  113. META
  114.  
  115. CODE EXIT     ( -- )
  116.         XCHG RP, SP     \ 4 cycles
  117.         POP IP          \ 8 cycles
  118.         POP ES          \ 8 cycles
  119.         XCHG RP, SP     \ 4 cycles
  120.         NEXT
  121.         END-CODE
  122.  
  123. CODE UNNEST   ( --- )
  124.         XCHG RP, SP     \ 4 cycles
  125.         POP IP          \ 8 cycles
  126.         POP ES          \ 8 cycles
  127.         XCHG RP, SP     \ 4 cycles
  128.         NEXT
  129.         END-CODE
  130.  
  131. CODE ?EXIT      ( f1 -- )  \ exit from definition on boolean f1.
  132.                 POP AX
  133.                 OR AX, AX
  134.         0<> IF
  135.                 JMP ' EXIT
  136.         THEN
  137.                 NEXT
  138.                 END-CODE
  139.  
  140. LABEL DODOES
  141.         XCHG RP, SP     \  4 cycles
  142.         PUSH ES         \ 10 sysles
  143.         PUSH IP         \ 11 cycles
  144.         XCHG RP, SP     \  4 cycles
  145.         POP DI
  146.         MOV AX, 0 [DI]
  147.         ADD AX, XSEG
  148.         MOV ES, AX
  149.         SUB IP, IP
  150.         NEXT            END-CODE
  151.  
  152. VARIABLE UP
  153.  
  154. LABEL DOCONSTANT
  155.         POP BX          PUSH 0 [BX]
  156.         NEXT            END-CODE
  157.  
  158. LABEL DOVALUE                           \ Save as constant, but it is assumed
  159.         POP BX          PUSH 0 [BX]     \ the user may change it.
  160.         NEXT            END-CODE
  161.  
  162. LABEL DOUSER-VARIABLE
  163.         POP BX
  164.         MOV AX, 0 [BX]
  165.         ADD AX, UP
  166.         1PUSH           END-CODE
  167.  
  168. CODE (LIT)      ( -- n )
  169.                 LODSW ES:       1PUSH           END-CODE
  170.  
  171. T: LITERAL      ( n -- ) [TARGET] (LIT)   ,-X   T;
  172. T: DLITERAL     ( d -- ) [TARGET] (LIT) ,-X   [TARGET] (LIT) ,-X   T;
  173. T: ASCII        ( -- )   [COMPILE] ASCII [[ TRANSITION ]] LITERAL [META]  T;
  174. T: [']          ( -- )   'T >BODY @
  175.                          [[ TRANSITION ]] LITERAL  [META]   T;
  176. : CONSTANT      ( n -- )
  177.                 RECREATE   232 C,-T
  178.                 [[ ASSEMBLER DOCONSTANT ]] LITERAL HERE 2+ - ,-T
  179.                 DUP ,-T   CONSTANT   ;
  180.  
  181. : VALUE         ( n -- )
  182.                 RECREATE   232 C,-T
  183.                 [[ ASSEMBLER DOVALUE    ]] LITERAL HERE 2+ - ,-T
  184.                 DUP ,-T   VALUE      ;
  185.  
  186. FORWARD: <(;CODE)>
  187. T: DOES>        ( -- )
  188.                 [FORWARD] <(;CODE)> HERE-T ,-X
  189.                 HERE-T  ( DOES-OP ) 232 C,-T
  190.                 [[ ASSEMBLER DODOES ]] LITERAL HERE 2+ - ,-T
  191.                 HERE-X PARAGRAPH-X + DUP DPSEG-X ! SEG-X @ - ,-T
  192.                 DP-X OFF T;
  193.  
  194. : NUMERIC   ( -- )
  195.                 [FORTH] HERE [META] NUMBER   DPL @ 1+
  196.                 IF      [[ TRANSITION ]] DLITERAL [META]
  197.                 ELSE    DROP   [[ TRANSITION ]] LITERAL [META]   THEN  ;
  198.  
  199. : UNDEFINED     ( -- )
  200.                 HERE-X >XREL 0 ,-X
  201.                 CR >IN @ BL WORD COUNT TYPE >IN !
  202.                 15 #OUT @ - SPACES .SEQHANDLE
  203.                 40 #OUT @ - SPACES ERRORLINE @ 4 .R
  204.                 ."   Forward reference or unresolved."
  205.                 IN-FORWARD  [FORTH] CREATE [META] TRANSITION
  206.                 [FORTH] ,   FALSE ,   [META]
  207.                 DOES>   FORWARD-CODE   ;
  208.  
  209. [FORTH] VARIABLE T-IN      META
  210.  
  211. : ]             ( -- )
  212.                 STATE-T ON   IN-TRANSITION
  213.         BEGIN   >IN @ T-IN !
  214.                 BEGIN   BL WORD DUP C@ 0=       \ If nothing in line
  215.                         ?FILLBUFF               \ Optionally refill buffer
  216.                         INLENGTH 0> AND         \ and input buf not empty
  217.                 WHILE   DROP 0 T-IN !
  218.                         FILLTIB            \ refill the buffer
  219.                 REPEAT  ?UPPERCASE FIND
  220.                 IF      EXECUTE
  221.                 ELSE    COUNT NUMERIC?
  222.                         IF      NUMERIC
  223.                         ELSE    T-IN @ >IN !   UNDEFINED
  224.                         THEN
  225.                 THEN    STATE-T @ 0=
  226.         UNTIL ;
  227.  
  228. T: [   ( -- )   IN-META   STATE-T OFF   T;
  229.  
  230. T: ;   ( -- )   [TARGET] UNNEST   [[ TRANSITION ]] [   T;
  231.  
  232.  : :   ( -- )   TARGET-CREATE   233 C,-T        \ a JUMP instruction
  233.                 [[ ASSEMBLER NEST ]] LITERAL HERE 2+ - ,-T
  234.                 HERE-X PARAGRAPH-X + DUP DPSEG-X !
  235.                 SEG-X @ - ( DUP H. ) ,-T
  236.                 DP-X OFF ] ;                              \ compile body addr
  237.  
  238. ASSEMBLER CLEAR_LABELS META
  239.  
  240. CODE DOBEGIN    ( -- )  \ REALLY A NOOP
  241.                 NEXT    END-CODE
  242.  
  243. CODE DOTHEN     ( -- )  \ REALLY A NOOP
  244.                 NEXT    END-CODE
  245.  
  246. CODE DOAGAIN    ( -- )
  247.                 MOV ES: IP, 0 [IP]
  248.                 NEXT           END-CODE
  249.  
  250. CODE DOREPEAT   ( -- )
  251. LABEL DOREP1    MOV ES: IP, 0 [IP]
  252.                 NEXT           END-CODE
  253.  
  254. CODE ?WHILE     ( f -- )
  255.                 POP AX          OR AX, AX
  256.                 JE DOREP1
  257.                 ADD IP, # 2
  258.                 NEXT            END-CODE
  259.  
  260. CODE ?UNTIL     ( f -- )
  261.                 POP AX          OR AX, AX
  262.                 JE DOREP1
  263.                 ADD IP, # 2
  264.                 NEXT            END-CODE
  265.  
  266. CODE BRANCH     ( -- )
  267. LABEL BRAN1     MOV ES: IP, 0 [IP]
  268.                 NEXT            END-CODE
  269.  
  270. CODE ?BRANCH    ( f -- )
  271.                 POP AX          OR AX, AX
  272.                 JE BRAN1
  273.                 ADD IP, # 2
  274.                 NEXT            END-CODE
  275.  
  276. T: BEGIN        [TARGET] DOBEGIN X?<MARK   T;
  277. T: AGAIN        [TARGET] DOAGAIN X?<RESOLVE   T;
  278. T: UNTIL        [TARGET] ?UNTIL  X?<RESOLVE   T;
  279. T: IF           [TARGET] ?BRANCH X?>MARK      T;
  280. T: THEN         [TARGET] DOTHEN  X?>RESOLVE    T;
  281. T: ELSE         [TARGET] BRANCH  X?>MARK   2SWAP X?>RESOLVE   T;
  282. T: WHILE        [TARGET] ?WHILE  X?>MARK   T;
  283. T: REPEAT       2SWAP [TARGET] DOREPEAT X?<RESOLVE X?>RESOLVE T;
  284.  
  285. LABEL LOOPEXIT  ( --- )
  286.                 ADD RP, # 6     ADD IP, # 2
  287.                 NEXT            END-CODE
  288.  
  289. CODE UNDO       ( --- )
  290.                 ADD RP, # 6
  291.                 NEXT            END-CODE
  292.  
  293. CODE (LOOP)     ( -- )
  294.                 INC 0 [RP] WORD
  295.                 JO LOOPEXIT
  296.                 MOV ES: IP, 0 [IP]
  297.                 NEXT            END-CODE
  298.  
  299. CODE (+LOOP)    ( n -- )
  300.                 AX POP          ADD 0 [RP], AX
  301.                 JO LOOPEXIT     MOV ES: IP, 0 [IP]
  302.                 NEXT            END-CODE
  303.  
  304. CODE (DO)       ( l i -- )
  305.                 POP DX          POP BX
  306. LABEL PDO1      XCHG RP, SP             \ 4
  307.                 LODSW ES:               \ 12 + 2
  308.                 PUSH AX                 \ 11
  309.                 ADD BX, # $8000          \ 4
  310.                 PUSH BX                 \ 11
  311.                 SUB DX, BX              \ 3
  312.                 PUSH DX                 \ 11
  313.                 XCHG RP, SP             \ 4     = 62
  314.                 NEXT            END-CODE
  315.  
  316. CODE (?DO)      ( l i -- )
  317.                 POP DX          POP BX
  318.                 CMP BX, DX
  319.                 JNE PDO1        MOV ES: IP, 0 [IP]
  320.                 NEXT            END-CODE
  321.  
  322. CODE (OF)       ( n1 n2 -- n1 )  ( or )  ( n1 n1 -- )
  323.                 POP AX          POP BX
  324.                 CMP AX, BX
  325.         0= IF
  326.                 ADD IP, # 2     NEXT
  327.         ELSE
  328.                 PUSH BX
  329.                 MOV ES: IP, 0 [IP]
  330.                 NEXT
  331.         THEN
  332.                 END-CODE
  333.  
  334. CODE BOUNDS     ( n1 n2 --- n3 n4 )
  335.                 POP DX          POP AX          ADD DX, AX
  336.                 2PUSH           END-CODE
  337.  
  338. T: ?DO          [TARGET] (?DO)   X?>MARK   T;
  339. T: DO           [TARGET] (DO)    X?>MARK   T;
  340. T: LOOP         [TARGET] (LOOP)    2DUP 2+   X?<RESOLVE   X?>RESOLVE   T;
  341. T: +LOOP        [TARGET] (+LOOP)   2DUP 2+   X?<RESOLVE   X?>RESOLVE   T;
  342.  
  343. ASSEMBLER >NEXT META CONSTANT >NEXT
  344. ASSEMBLER  NEST META CONSTANT >NEST
  345.  
  346. CODE EXECUTE    ( cfa -- )
  347.                 POP AX          JMP AX          END-CODE
  348.  
  349. CODE PERFORM    ( addr-of-cfa -- )
  350. LABEL DODEFER   POP BX          MOV AX, 0 [BX]
  351.                 JMP AX          END-CODE
  352.  
  353. CODE EXEC:      ( N1 -- )
  354.                 POP BX
  355.                 SHL BX, # 1
  356.                 ADD IP, BX
  357.                 LODSW ES:
  358.                 XCHG RP, SP     \ 4
  359.                 POP IP          \ 8
  360.                 POP ES          \ 8
  361.                 XCHG RP, SP     \ 4     = 24
  362.                 JMP AX          END-CODE
  363.  
  364. LABEL DOUSER-DEFER
  365.                 POP BX          MOV BX, 0 [BX]
  366.                 ADD BX, UP      MOV AX, 0 [BX]
  367.                 JMP AX          END-CODE
  368.  
  369. CODE GO         RET             END-CODE        ( ADDR --- )
  370.  
  371. CODE NOOP       NEXT            END-CODE
  372.  
  373. CODE PAUSE      NOOP                            \ Gets patched
  374.                 NOOP
  375.                 NOOP
  376.                 NEXT            END-CODE
  377.  
  378. CODE I ( -- n ) MOV AX, 0 [RP]  ADD AX, 2 [RP]
  379.                 1PUSH           END-CODE
  380.  
  381. CODE J ( -- n ) MOV AX, 6 [RP]  ADD AX, 8 [RP]
  382.                 1PUSH           END-CODE
  383.  
  384. CODE K ( -- n ) MOV AX, 12 [RP] ADD AX, 14 [RP]
  385.                 1PUSH           END-CODE
  386.  
  387. CODE (LEAVE)    ( -- )
  388. LABEL PLEAVE    ADD RP, # 4     MOV IP, 0 [RP]
  389.                 ADD RP, # 2
  390.                 NEXT            END-CODE
  391.  
  392. CODE (?LEAVE)   ( f -- )
  393.                 POP AX          OR AX, AX       JNE PLEAVE
  394.                 NEXT            END-CODE
  395.  
  396. T: LEAVE        [TARGET] (LEAVE)   T;
  397. T: ?LEAVE       [TARGET] (?LEAVE)  T;
  398.  
  399. CODE @          ( addr -- n )
  400.                 POP BX          PUSH 0 [BX]
  401.                 NEXT            END-CODE
  402.  
  403. CODE !          ( n addr -- )
  404.                 POP BX          POP 0 [BX]
  405.                 NEXT            END-CODE
  406.  
  407. CODE C@         ( addr -- char )
  408.                 POP BX          SUB AX, AX      MOV AL, 0 [BX]
  409.                 1PUSH           END-CODE
  410.  
  411. CODE C!         ( char addr -- )
  412.                 POP BX          POP AX          MOV 0 [BX], AL
  413.                 NEXT            END-CODE
  414.  
  415. CODE CMOVE      (  from to count -- )
  416.                 CLD             MOV BX, IP      MOV AX, DS
  417.                 POP CX          POP DI          POP IP
  418.                 PUSH ES         MOV ES, AX
  419.                 REPNZ           MOVSB
  420.                 MOV IP, BX      POP ES
  421.                 NEXT            END-CODE
  422.  
  423. CODE CMOVE>     ( from to count -- )
  424.                 STD             MOV BX, IP      MOV AX, DS
  425.                 POP CX          DEC CX
  426.                 POP DI          POP IP
  427.                 ADD DI, CX      ADD IP, CX      INC CX
  428.                 PUSH ES         MOV ES, AX
  429.                 REPNZ           MOVSB
  430.                 MOV IP, BX      CLD             POP ES
  431.                 NEXT            END-CODE
  432.  
  433. CODE PLACE      ( from cnt to -- )
  434.                 POP BX          POP AX          MOV 0 [BX], AL
  435.                 INC BX          PUSH BX         PUSH AX
  436.                 CLD             MOV BX, IP      MOV AX, DS
  437.                 POP CX          POP DI          POP IP
  438.                 PUSH ES         MOV ES, AX
  439.                 REPNZ           MOVSB
  440.                 MOV IP, BX      POP ES
  441.                 NEXT            END-CODE
  442.  
  443. DECIMAL
  444.  
  445. CODE SP@        ( -- n )
  446.                 MOV AX, SP      1PUSH           END-CODE
  447. \ Cant use the following because it doesn't work on an 8088.
  448. \               PUSH SP         NEXT            END-CODE
  449.  
  450. CODE SP!        ( n -- )
  451.                 POP SP          NEXT            END-CODE
  452.  
  453. CODE RP@        ( -- addr )
  454.                 PUSH RP         NEXT            END-CODE
  455.  
  456. CODE RP!        ( n -- )
  457.                 POP RP          NEXT            END-CODE
  458.  
  459. CODE DROP       ( n1 -- )
  460.                 ADD SP, # 2     NEXT            END-CODE
  461.  
  462. CODE DUP        ( n1 -- n1 n1 )
  463.                 POP AX          PUSH AX
  464.                 1PUSH           END-CODE
  465.  
  466. CODE SWAP       ( n1 n2 -- n2 n1 )
  467.                 POP DX          POP AX
  468.                 2PUSH           END-CODE
  469.  
  470. CODE OVER       ( n1 n2 -- n1 n2 n1 )
  471.                 XCHG RP, SP
  472.                 MOV AX, 2 [RP]
  473.                 XCHG RP, SP
  474.                 1PUSH           END-CODE
  475.  
  476. CODE TUCK       ( n1 n2 -- n2 n1 n2 )
  477.                 POP AX          POP DX
  478.                 PUSH AX         2PUSH           END-CODE
  479.  
  480. CODE NIP        ( n1 n2 -- n2 )
  481.                 POP AX          ADD SP, # 2
  482.                 1PUSH           END-CODE
  483.  
  484. CODE ROT        ( n1 n2 n3 --- n2 n3 n1 )
  485.                 POP DX          POP BX          POP AX
  486.                 PUSH BX         2PUSH           END-CODE
  487.  
  488. CODE -ROT       ( n1 n2 n3 --- n3 n1 n2 )
  489.                 POP BX          POP AX          POP DX
  490.                 PUSH BX         2PUSH           END-CODE
  491.  
  492. CODE FLIP       ( n1 -- n2 )
  493.                 POP AX          XCHG AL, AH
  494.                 1PUSH           END-CODE
  495.  
  496. CODE SPLIT      ( n1 --- n2 n3 )        \ Splits n1 into two bytes, low, high
  497.                 POP BX
  498.                 SUB AX, AX
  499.                 MOV AL, BL
  500.                 PUSH AX
  501.                 MOV AL, BH
  502.                 1PUSH           END-CODE
  503.  
  504. CODE ?DUP       ( n1 -- [n1] n1 )
  505.                 POP AX          CMP AX, # 0
  506.             0<> IF
  507.                 PUSH AX
  508.             THEN
  509.                 1PUSH           END-CODE
  510.  
  511. CODE R>         ( -- n )
  512.                 PUSH 0 [RP]
  513.                 ADD RP, # 2
  514.                 NEXT            END-CODE
  515.  
  516. CODE R>DROP     ( --- )
  517.                 ADD RP, # 2
  518.                 NEXT            END-CODE
  519.  
  520. CODE DUP>R      ( n1 --- n1 )
  521.                 POP AX
  522.                 PUSH AX
  523.                 SUB RP, # 2
  524.                 MOV 0 [RP], AX
  525.                 NEXT            END-CODE
  526.  
  527. CODE >R         ( n -- )
  528.                 SUB RP, # 2     \  4
  529.                 POP 0 [RP]      \ 22 = 26 cycles
  530.                 NEXT            END-CODE
  531.  
  532. CODE 2R>        ( -- n )
  533.                 PUSH 2 [RP]     \ 25
  534.                 PUSH 0 [RP]     \ 21
  535.                 ADD RP, # 4     \  4 = 50 cycles
  536.                 NEXT            END-CODE
  537.  
  538. CODE 2>R        ( n -- )
  539.                 SUB RP, # 4     \  4
  540.                 POP 0 [RP]      \ 22
  541.                 POP 2 [RP]      \ 26 = 52 cycles
  542.                 NEXT            END-CODE
  543.  
  544. CODE R@         ( -- n )
  545.                 PUSH 0 [RP]
  546.                 NEXT            END-CODE
  547.  
  548. CODE 2R@        ( -- n )
  549.                 PUSH 2 [RP]
  550.                 PUSH 0 [RP]
  551.                 NEXT            END-CODE
  552.  
  553. CODE PICK       ( nm ... n2 n1 k -- nm ... n2 n1 nk )
  554.                 POP BX          SHL BX, # 1     ADD BX, SP
  555.                 PUSH 0 [BX]
  556.                 NEXT            END-CODE
  557.  
  558. CODE AND        ( n1 n2 -- n3 )
  559.                 POP BX          POP AX          AND AX, BX
  560.                 1PUSH           END-CODE
  561.  
  562. CODE OR         ( n1 n2 -- n3 )
  563.                 POP BX          POP AX          OR AX, BX
  564.                 1PUSH           END-CODE
  565.  
  566. CODE XOR        ( n1 n2 -- n3 )
  567.                 POP BX          POP AX          XOR AX, BX
  568.                 1PUSH           END-CODE
  569.  
  570. CODE NOT        ( n -- n' )
  571.                 POP AX          NOT AX
  572.                 1PUSH           END-CODE
  573.  
  574. -1 CONSTANT TRUE
  575.  0 CONSTANT FALSE
  576.  
  577. CODE CSET       ( b addr -- )
  578.                 POP BX          POP AX          OR 0 [BX], AL
  579.                 NEXT            END-CODE
  580.  
  581. CODE CRESET     ( b addr -- )
  582.                 POP BX          POP AX
  583.                 NOT AX          AND 0 [BX], AL
  584.                 NEXT            END-CODE
  585.  
  586. CODE CTOGGLE    ( b addr -- )
  587.                 POP BX          POP AX          XOR 0 [BX], AL
  588.                 NEXT            END-CODE
  589.  
  590. CODE ON         ( addr -- )
  591.                 POP BX          MOV 0 [BX], # TRUE WORD
  592.                 NEXT            END-CODE
  593.  
  594. CODE OFF        ( addr -- )
  595.                 POP BX          MOV 0 [BX], # FALSE WORD
  596.                 NEXT            END-CODE
  597.  
  598. CODE -1!        ( addr -- )
  599.                 POP BX          MOV 0 [BX], # TRUE WORD
  600.                 NEXT            END-CODE
  601.  
  602. CODE 0!         ( addr -- )
  603.                 POP BX          MOV 0 [BX], # FALSE WORD
  604.                 NEXT            END-CODE
  605.  
  606. CODE INCR       ( A1 --- )
  607.                 POP BX          INC 0 [BX] WORD
  608.                 NEXT            END-CODE
  609.  
  610. CODE DECR       ( A1 --- )
  611.                 POP BX          DEC 0 [BX] WORD
  612.                 NEXT            END-CODE
  613.  
  614. CODE +          ( n1 n2 -- sum )
  615.                 POP BX          POP AX          ADD AX, BX
  616.                 1PUSH           END-CODE
  617.  
  618. CODE NEGATE     ( n -- n' )
  619.                 POP AX          NEG AX
  620.                 1PUSH           END-CODE
  621.  
  622. CODE -          ( n1 n2 -- n1-n2 )
  623.                 POP BX          POP AX          SUB AX, BX
  624.                 1PUSH           END-CODE
  625.  
  626. CODE ABS        ( n -- n )
  627.                 POP AX
  628.                 CWD
  629.                 XOR AX, DX
  630.                 SUB AX, DX
  631.                 1PUSH
  632.                 END-CODE
  633.  
  634. CODE 2+!        ( d addr -- )
  635.                 POP BX          POP AX          POP DX
  636.                 ADD 2 [BX], DX  ADC 0 [BX], AX
  637.                 NEXT            END-CODE
  638.  
  639. CODE +!         ( n addr -- )
  640.                 POP BX          POP AX          ADD 0 [BX], AX
  641.                 NEXT            END-CODE
  642.  
  643. CODE C+!        ( n addr -- )
  644.                 POP BX          POP AX          ADD 0 [BX], AL
  645.                 NEXT            END-CODE
  646.  
  647.  
  648. \ Since the 8086 has a seperate IO path, we define a Forth
  649. \ interface to it.  Use P@ and P! to read or write directly to
  650. \ the 8086 IO ports.
  651.  
  652. CODE PC@        ( port# -- n )
  653.                 POP DX          IN AL, DX       SUB AH, AH
  654.                 PUSH AX         NEXT            END-CODE
  655.  
  656. CODE P@         ( port# -- n )
  657.                 POP DX          IN AX, DX       PUSH AX
  658.                 NEXT            END-CODE
  659.  
  660. CODE PC!        ( n port# -- )
  661.                 POP DX          POP AX          OUT DX, AL
  662.                 NEXT            END-CODE
  663.  
  664. CODE P!         ( n port# -- )
  665.                 POP DX          POP AX          OUT DX, AX
  666.                 NEXT            END-CODE
  667.  
  668.                 \ read drive path into addr, null terminated.
  669. CODE PDOS       ( addr drive --- f1 ) \ RETURN PATH OF DRIVE
  670.                 pop dx          pop ax
  671.                 push si         mov si, ax
  672.                 mov ah, # $47   int $21
  673.              u< if
  674.                 mov al, # 1
  675.              else
  676.                 mov al, # 0
  677.              then
  678.                 sub ah, ah      pop si
  679.                 1push           end-code
  680.  
  681. #TTHREADS CONSTANT #THREADS
  682.  
  683. CODE 2*         ( n -- 2*n )
  684.                 POP AX          SHL AX, # 1
  685.                 1PUSH           END-CODE
  686.  
  687. CODE 2/         ( n -- n/2 )
  688.                 POP AX          SAR AX, # 1
  689.                 1PUSH           END-CODE
  690.  
  691. CODE U2/        ( u -- u/2 )
  692.                 POP AX          SHR AX, # 1
  693.                 1PUSH           END-CODE
  694.  
  695. CODE U16/       ( u -- u/16 )
  696.                 POP AX
  697.                 SHR AX, # 1     SHR AX, # 1
  698.                 SHR AX, # 1     SHR AX, # 1
  699.                 1PUSH           END-CODE
  700.  
  701. CODE 8*         ( n -- 8*n )
  702.                 POP AX          SHL AX, # 1
  703.                 SHL AX, # 1     SHL AX, # 1
  704.                 1PUSH           END-CODE
  705.  
  706.                 ( n1 --- n2 )
  707. CODE 1+         POP AX          INC AX
  708.                 1PUSH           END-CODE
  709.  
  710. CODE 2+         POP AX          ADD AX, # 2
  711.                 1PUSH           END-CODE
  712.  
  713. CODE 1-         POP AX          DEC AX
  714.                 1PUSH           END-CODE
  715.  
  716. CODE 2-         POP AX          SUB AX, # 2
  717.                 1PUSH           END-CODE
  718.  
  719. CODE UM*        ( n1 n2 -- d )
  720.                 POP AX          POP BX          MUL BX
  721.                 XCHG DX, AX     2PUSH           END-CODE
  722.  
  723. CODE *          ( N1 N2 -- N3 )
  724.                 POP AX          POP BX          MUL BX
  725.                 1PUSH           END-CODE
  726.  
  727. : U*D           ( n1 n2 -- d )  UM*   ;
  728.  
  729. CODE UM/MOD     ( d1 n1 -- Remainder Quotient )
  730.                 POP BX          POP DX          POP AX
  731.                 CMP DX, BX
  732.             U>=  ( divide by zero? )
  733.             IF
  734.                 MOV AX, # -1    MOV DX, AX      2PUSH
  735.             THEN
  736.                 DIV BX          2PUSH           END-CODE
  737.  
  738. LABEL YES       MOV AX, # TRUE  1PUSH           END-CODE
  739.  
  740. CODE 0=         ( n -- f )
  741.                 POP AX          OR AX, AX
  742.                 JE YES
  743.                 SUB AX, AX      1PUSH           END-CODE
  744.  
  745. CODE 0<         ( n -- f )
  746.                 POP AX          OR AX, AX
  747.                 JS YES
  748.                 SUB AX, AX      1PUSH           END-CODE
  749.  
  750. CODE 0>         ( n -- f )
  751.                 POP AX          OR AX, AX
  752.                 JG YES
  753.                 SUB AX, AX      1PUSH           END-CODE
  754.  
  755. CODE 0<>        ( n -- f )
  756.                 POP AX          OR AX, AX
  757.                 JNE YES
  758.                 SUB AX, AX      1PUSH           END-CODE
  759.  
  760. CODE =          ( n1 n2 -- f )
  761.                 POP AX          POP BX          CMP BX, AX
  762.                 JE YES
  763.                 SUB AX, AX      1PUSH           END-CODE
  764.  
  765. CODE <>         ( n1 n2 -- f )
  766.                 POP AX          POP BX          CMP BX, AX
  767.                 JNE YES
  768.                 SUB AX, AX      1PUSH           END-CODE
  769.  
  770. \ : <>            ( n1 n2 -- f )  = NOT   ;
  771.  
  772. : ?NEGATE       ( n1 n2 -- n3 ) 0< IF    NEGATE   THEN   ;
  773.  
  774. CODE   U<       ( n1 n2 -- f )
  775.                 POP AX          POP BX          CMP BX, AX
  776.                 JB YES
  777.                 SUB AX, AX      1PUSH           END-CODE
  778.  
  779. CODE   U>       ( n1 n2 -- f )
  780.                 POP AX          POP BX          CMP AX, BX
  781.                 JB YES
  782.                 SUB AX, AX      1PUSH           END-CODE
  783.  
  784. LABEL YES1      MOV AX, # TRUE  1PUSH           END-CODE
  785.  
  786. CODE <          ( n1 n2 -- f )
  787.                 POP AX          POP BX          CMP BX, AX
  788.                 JL YES1
  789.                 SUB AX, AX      1PUSH           END-CODE
  790.  
  791. CODE >          ( n1 n2 -- f )
  792.                 POP AX          POP BX          CMP BX, AX
  793.                 JG YES1
  794.                 SUB AX, AX
  795. LABEL PUSH1     1PUSH           END-CODE
  796.  
  797. CODE MIN        POP AX          POP BX          CMP BX, AX
  798.                 JG PUSH1
  799. LABEL MIN1      PUSH BX         NEXT            END-CODE
  800.  
  801. CODE MAX        POP AX          POP BX          CMP BX, AX
  802.                 JG MIN1
  803.                 1PUSH           END-CODE
  804.  
  805. : BETWEEN       ( n1 min max -- f )     >R  OVER > SWAP R> > OR NOT ;
  806. : WITHIN        ( n1 min max -- f )     1- BETWEEN  ;
  807.  
  808. CODE 2@         ( addr -- d )
  809.                 POP BX
  810.                 PUSH 2 [BX]
  811.                 PUSH 0 [BX]
  812.                 NEXT            END-CODE
  813.  
  814. CODE 2!         ( d addr -- )
  815.                 POP BX          POP 0 [BX]      POP 2 [BX]
  816.                 NEXT            END-CODE
  817.  
  818. CODE 2DROP      ( d -- )
  819.                 ADD SP, # 4
  820.                 NEXT            END-CODE
  821.  
  822. CODE 3DROP      ( n1 n2 n3 -- )
  823.                 ADD SP, # 6
  824.                 NEXT            END-CODE
  825.  
  826. CODE 2DUP       ( d -- d d )
  827.                 POP AX          POP DX
  828.                 PUSH DX         PUSH AX
  829.                 2PUSH           END-CODE
  830.  
  831. CODE 3DUP       ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )
  832.                 POP AX          POP DX          POP BX
  833.                 PUSH BX         PUSH DX         PUSH AX
  834.                 PUSH BX
  835.                 2PUSH           END-CODE
  836.  
  837. CODE 2SWAP      ( d1 d2 -- d2 d1 )
  838.                 POP CX          POP BX
  839.                 POP AX          POP DX
  840.                 PUSH BX         PUSH CX
  841.                 2PUSH           END-CODE
  842.  
  843. CODE 2OVER      ( d2 d2 -- d1 d2 d1 )
  844.                 XCHG RP, SP
  845.                 MOV AX, 4 [RP]
  846.                 MOV DX, 6 [RP]
  847.                 XCHG RP, SP
  848.                 2PUSH           END-CODE
  849.  
  850. CODE D+         ( d1 d2 -- dsum )
  851.                 POP AX          POP DX
  852.                 POP BX          POP CX
  853.                 ADD DX, CX      ADC AX, BX
  854.                 2PUSH           END-CODE
  855.  
  856. CODE DNEGATE    ( d# -- d#' )
  857.                 POP AX
  858. LABEL DNEG1     POP DX
  859.                 NEG AX
  860.                 NEG DX
  861.                 SBB AX, # 0
  862.                 2PUSH
  863.                 END-CODE
  864.  
  865. CODE   S>D      ( n -- d )
  866.                 POP AX          CWD             XCHG DX, AX
  867.                 2PUSH           END-CODE
  868.  
  869. CODE DABS       ( d# -- d# )
  870.                 POP AX
  871.                 OR AX, AX
  872.                 JS DNEG1
  873.                 1PUSH           END-CODE
  874.  
  875. CODE D2*        ( d -- d*2 )
  876.                 POP AX          POP DX
  877.                 SHL DX, # 1     RCL AX, # 1
  878.                 2PUSH           END-CODE
  879.  
  880. CODE D2/        ( d -- d/2 )
  881.                 POP AX          POP DX
  882.                 SAR AX, # 1     RCR DX, # 1
  883.                 2PUSH           END-CODE
  884.  
  885. : D-            ( d1 d2 -- d3 ) DNEGATE D+   ;
  886.  
  887. : ?DNEGATE      ( d1 n -- d2 )  0< IF   DNEGATE   THEN   ;
  888.  
  889. : D0=           ( d -- f )      OR 0= ;
  890.  
  891. : D=            ( d1 d2 -- f )  D-  D0=  ;
  892.  
  893. : DU<           ( ud1 ud2 -- f )
  894.                 ROT SWAP 2DUP U<
  895.                 IF      2DROP 2DROP TRUE
  896.                 ELSE    <> IF   2DROP FALSE  ELSE  U<  THEN
  897.                 THEN  ;
  898.  
  899. : D<            ( d1 d2 -- f )
  900.                 2 PICK OVER =
  901.                 IF      DU<
  902.                 ELSE  NIP ROT DROP <  THEN  ;
  903.  
  904. : D>            ( d1 d2 -- f )  2SWAP D<   ;
  905.  
  906. : 4DUP          ( a b c d -- a b c d a b c d )  2OVER 2OVER   ;
  907.  
  908. : DMIN          ( d1 d2 -- d3 ) 4DUP D> IF  2SWAP  THEN 2DROP ;
  909.  
  910. : DMAX          ( d1 d2 -- d3 ) 4DUP D< IF  2SWAP  THEN  2DROP ;
  911.  
  912. : *D            ( n1 n2 -- d# )
  913.                 2DUP  XOR  >R  ABS  SWAP  ABS  UM*  R>  ?DNEGATE  ;
  914.  
  915. : M/MOD         ( d# n1 -- rem quot )
  916.                 ?DUP
  917.                 IF  dup>r  2DUP XOR >R  >R DABS R@ ABS  UM/MOD
  918.                         SWAP R> ?NEGATE
  919.                         SWAP R> 0<
  920.                         IF  NEGATE OVER
  921.                                 IF  1- R@ ROT - SWAP  THEN
  922.                         THEN    r>drop
  923.                 THEN  ;
  924.  
  925. : MU/MOD        ( d# n1 -- rem d#quot )
  926.                 >R  0  R@  UM/MOD  R>  SWAP  >R  UM/MOD  R>   ;
  927.  
  928. CODE /          ( NUM DEN --- QUOT )
  929.                 POP BX          POP AX          CWD
  930.                 MOV CX, BX      XOR CX, DX
  931.             0>= IF                              \ POSITIVE QUOTIENT CASE
  932.                 IDIV BX         1PUSH
  933.             THEN
  934.                 IDIV BX         OR DX, DX
  935.             0<> IF
  936.                 DEC AX
  937.             THEN
  938.                 1PUSH           END-CODE
  939.  
  940. CODE /MOD       ( NUM DEN --- REM QUOT )
  941.                 POP BX          POP AX          CWD
  942.                 MOV CX, BX      XOR CX, DX
  943.             0>= IF
  944.                 IDIV BX         2PUSH
  945.             THEN
  946.                 IDIV BX         OR DX, DX
  947.             0<> IF
  948.                 ADD DX, BX      DEC AX
  949.            THEN
  950.                 2PUSH           END-CODE
  951.  
  952. : MOD           ( n1 n2 -- rem ) /MOD  DROP  ;
  953.  
  954. CODE */MOD      ( N1 N2 N3 --- REM QUOT )
  955.                 POP BX          POP AX          POP CX
  956.                 IMUL CX         MOV CX, BX      XOR CX, DX
  957.             0>= IF
  958.                 IDIV BX         2PUSH
  959.             THEN
  960.                 IDIV BX         OR DX, DX
  961.             0<> IF
  962.                 ADD DX, BX      DEC AX
  963.             THEN
  964.                 2PUSH           END-CODE
  965.  
  966. : */            ( n1 n2 n3 -- n1*n2/n3 ) */MOD  NIP  ;
  967.  
  968. : ROLL          ( n1 n2 .. nk n -- wierd )
  969.                 >R R@ PICK   SP@ DUP 2+   R> 1+ 2* CMOVE>  DROP  ;
  970.  
  971. : 2ROT          ( a b c d e f - c d e f a b )   5 ROLL  5 ROLL  ;
  972.  
  973.  
  974.